home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 2: CDPD 1 / Almathera Ten on Ten - Disc 2: CDPD 1.iso / pd / 076-100 / 084 / gravitywars / gw.mod < prev    next >
Text File  |  1995-03-13  |  13KB  |  409 lines
  1. IMPLEMENTATION MODULE GW;
  2.  
  3. (*+,+*)
  4.  
  5. (**********************************************************************
  6. ***************           Written by Ed Bartz           ***************
  7. ***************           Copyright  5/21/87            ***************
  8. ***************    This program may be redistributed    ***************
  9. ***************    or modified as long as these         ***************
  10. ***************    notices and all other references     ***************
  11. ***************    to the author remain intack.         ***************
  12. ***************    Also this may not be used for        ***************
  13. ***************    profit by anyone without the         ***************
  14. ***************    express permission of the author.    ***************
  15. **********************************************************************)
  16.  
  17. FROM SYSTEM     IMPORT ADR, BYTE, ADDRESS, NULL, WORD;
  18. FROM Areas  IMPORT AreaInfo, AreaInfoPtr, AreaEllipse, AreaEnd, InitArea;
  19. FROM Intuition  IMPORT
  20.      IntuitionName, IntuitionBase, Window, WindowFlags, NewWindow,
  21.      MenuPick, IDCMPFlagSet, WindowFlagSet, WindowPtr, ScreenPtr, Screen,
  22.      MenuEnabled, MenuFlagSet, Menu, MenuItem, IntuitionText, ActiveWindow,
  23.      ItemFlagSet, ItemText, ItemEnabled, IntuiMessagePtr, CustomScreen ;
  24. FROM GraphicsLibrary IMPORT GraphicsName, GraphicsBase, Jam2, Jam1,
  25.      DrawingModeSet, BitMapPtr, BitMap, PlanePtr;
  26. FROM Windows IMPORT OpenWindow, CloseWindow;
  27. FROM Screens IMPORT NewScreen, OpenScreen, CloseScreen, ShowTitle;
  28. FROM RandomNumbers IMPORT Random;
  29. FROM MathLib0 IMPORT arctan,pi,real,entier,sin,cos,DegToRad,sqrt,power;
  30. FROM Rasters IMPORT SetRast, RastPort, RastPortPtr, TmpRas, InitTmpRas,
  31.      AllocRaster, FreeRaster;
  32. FROM Views IMPORT ModeSet;
  33. FROM Console   IMPORT
  34.      OpenWConsole,CloseWConsole,PutChar,PutStr,GetChar,GetStr,Conport;
  35. FROM M2Conversions IMPORT ConvertReal, ConvertToReal;
  36. FROM Pens IMPORT Draw, Move,SetAPen,SetDrMd,ReadPixel,WritePixel;
  37. FROM InOut IMPORT WriteLn,WriteString;
  38. FROM MyWindow IMPORT ReadMenu;
  39.  
  40.   PROCEDURE Min (x,y :INTEGER) :INTEGER;
  41.     BEGIN
  42.      IF x < y THEN RETURN x;
  43.      ELSE RETURN y;
  44.      END;
  45.   END Min;
  46. (***********************************************************************)
  47.   PROCEDURE Max (x,y :INTEGER) :INTEGER;
  48.     BEGIN
  49.      IF x > y THEN RETURN x;
  50.      ELSE RETURN y;
  51.      END;
  52.   END Max;
  53. (***********************************************************************)
  54.   PROCEDURE Sdrwline(x1,x2,y1,y2: INTEGER;color: CARDINAL;wp: WindowPtr);
  55.  
  56.     VAR
  57.       i,j,k,l,m : INTEGER;
  58.       c1,c2 : CARDINAL;
  59.  
  60.     BEGIN
  61.       i:= ABS(y2-y1) DIV 3;
  62.       IF i>0 THEN
  63.         l:=Min(y1,y2);
  64.         j:= i + l;
  65.         FOR m:= 0 TO 2 DO
  66.           c2:=CARDINAL(j-l);
  67.           FOR k:= l TO j DO
  68.             c1:= Random(c2);
  69.             IF c1<(CARDINAL(k-l)) THEN c1:=1;ELSE c1:=0;END;
  70.             SetAPen (wp^.RPort,color+c1);
  71.             WritePixel(wp^.RPort,k,x2);
  72.             WritePixel(wp^.RPort,k,x1);
  73.           END;
  74.           l:=j;
  75.           j:=j+i;
  76.           color:= color+1;
  77.         END;
  78.         DrawLine(l,x2,Max(y1,y2),x2,color,wp);
  79.         DrawLine(l,x1,Max(y1,y2),x1,color,wp);
  80.       ELSE
  81.         DrawLine(y1,x1,y2,x1,color,wp);
  82.         DrawLine(y1,x2,y2,x2,color,wp);
  83.       END;
  84.     END Sdrwline;
  85.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  86.     PROCEDURE DrawPlanet(x,y,r:INTEGER;color,ptype: CARDINAL;wp: WindowPtr);
  87.  
  88.       CONST
  89.         round = 0.83;
  90.         
  91.       VAR
  92.         r1,itr,nx,ny,x1,x2,y1,y2 :INTEGER;
  93.  
  94.       BEGIN
  95.       IF color>3 THEN
  96.        IF ptype = 1 THEN
  97.          r1:=entier(real(r)*round);
  98.          itr := r1*r1;
  99.          FOR ny := 0 TO r1 DO
  100.            nx:=entier(sqrt(real(itr-ny*ny))/round);
  101.            x1:= x-nx;
  102.            x2:= x+nx;
  103.            y1:= y-ny;
  104.            y2:= y+ny;
  105.            IF x1<0 THEN x1:=0; END;
  106.            IF y1<0 THEN y1:=0; END;
  107.            IF x2>639 THEN x2:=639; END;
  108.            IF y2>399 THEN y2:=399; END;
  109.            Sdrwline(y1,y2,x1,x2,color,wp);
  110.          END;
  111.        ELSE
  112.          itr := r*r;
  113.          FOR nx := 0 TO r DO
  114.            ny:=entier(sqrt(real(itr-nx*nx))*round);
  115.            x1:= x-nx;
  116.            x2:= x+nx;
  117.            y1:= y-ny;
  118.            y2:= y+ny;
  119.            IF x1<0 THEN x1:=0; END;
  120.            IF y1<0 THEN y1:=0; END;
  121.            IF x2>639 THEN x2:=639; END;
  122.            IF y2>399 THEN y2:=399; END;
  123.            DrawLine(x1,y1,x1,y2,color+2,wp);
  124.            DrawLine(x2,y1,x2,y2,color+2,wp);
  125.          END;
  126.        END;
  127.      END;
  128.        IF color<2 THEN
  129.          itr := r*r;
  130.          FOR nx := 0 TO r DO
  131.            ny:=entier(sqrt(real(itr-nx*nx))*round);
  132.            x1:= x-nx;
  133.            x2:= x+nx;
  134.            y1:= y-ny;
  135.            y2:= y+ny;
  136.            IF x1<0 THEN x1:=0; END;
  137.            IF y1<0 THEN y1:=0; END;
  138.            IF x2>639 THEN x2:=639; END;
  139.            IF y2>399 THEN y2:=399; END;
  140.            DrawLine(x1,y1,x1,y2,0,wp);
  141.            DrawLine(x2,y1,x2,y2,0,wp);
  142.          END;
  143.        END;
  144.     END DrawPlanet;
  145.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  146.     PROCEDURE Distance(A,B :Pl):INTEGER;
  147.  
  148.       VAR
  149.         i : INTEGER;
  150.         m,l,k,n : REAL;
  151.  
  152.       BEGIN
  153.         m:=real(ABS(A.x-B.x));
  154.         k:=real(ABS(A.y-B.y))/0.83;
  155.         IF m <= 0.0 THEN m:=0.01;END;
  156.         IF k <= 0.0 THEN k:=0.01;END;
  157.         l:=sqrt(m*m+k*k);
  158.         i:=ABS(entier(l));
  159.  
  160.       RETURN i;
  161.     END Distance;
  162.   (*++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  163.  PROCEDURE Pposition (VAR PlanetPos: ARRAY OF Pl;Pnum,ptype: CARDINAL; w: WindowPtr);
  164.  
  165.     VAR
  166.       i,j,k,Stop1,Stop2 :INTEGER;
  167.       Ok:BOOLEAN;
  168.       r3 : REAL;
  169.       density : CARDINAL;
  170.       mass : ARRAY [0..2] OF REAL;
  171.  
  172.     BEGIN
  173.       mass[0] := 0.020;
  174.       mass[1] := 0.025;
  175.       mass[2] := 0.030;
  176.       Stop1:=0;
  177.       Stop2:=0;
  178.       i:=0;
  179.       WHILE i<INTEGER(Pnum) DO
  180.         WITH PlanetPos[i] DO
  181.           x := Random(519)+60;
  182.           y := Random(299)+50;
  183.           r := Random(40)+10;
  184.         END;
  185.         Ok:= TRUE;
  186.         j:=i-1;
  187.         WHILE ((j>=0)AND Ok) DO
  188.           k:=Distance(PlanetPos[i],PlanetPos[j]);
  189.           k:=k-PlanetPos[i].r-PlanetPos[j].r;
  190.           IF k<20 THEN
  191.             Ok := FALSE;
  192.           END;
  193.           j:=j-1;
  194.         END;
  195.         Stop1:= ReadMenu(w);
  196.         IF Stop1 = 1 THEN  Stop2:= 1; END;
  197.         IF Ok THEN
  198.           WITH PlanetPos[i] DO
  199.             r3:=real(r);
  200.             r3:=r3*r3*r3;
  201.             density:= Random(3);
  202.             color := (density*4)+4;
  203.             m := r3* mass[density];
  204.             IF Random(50)>47 THEN 
  205.               color := 0;
  206.               m := r3* mass[2];
  207.             END;
  208.             IF Stop2 = 0 THEN DrawPlanet(x,y,r,color,ptype,w); END;
  209.           END;
  210.           i:=i+1;
  211.         END;
  212.       END;
  213.     END Pposition;
  214.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  215. PROCEDURE Sposition(w: WindowPtr;VAR Ship,PPos: ARRAY OF Pl;Pnum: CARDINAL);
  216.  
  217.       VAR
  218.         k,m     : CARDINAL;
  219.         i,j,l   : INTEGER;
  220.         Ok      : BOOLEAN;
  221.  
  222.       BEGIN
  223.         FOR  k:= 0 TO 1 DO;
  224.         Ship[k].r := 18;
  225.           REPEAT 
  226.             m:=k*460+40;
  227.             Ship[k].y :=Random(300)+50;
  228.             Ship[k].x :=Random(100)+m;
  229.             Ok:=TRUE;
  230.             i:=0;
  231.             WHILE ((i<INTEGER(Pnum))AND Ok) DO
  232.               j:=Distance(Ship[k],PPos[i]);
  233.               IF j<PPos[i].r+40 THEN
  234.                 Ok:=FALSE;
  235.               END;
  236.               i:=i+1;
  237.             END;
  238.           UNTIL Ok;
  239.         END;
  240.         DrawShip(Ship[0].x,Ship[0].y,Ship[1].x,Ship[1].y,w);
  241.     END Sposition;
  242.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  243.     PROCEDURE Stars(wp: WindowPtr);
  244.  
  245.       VAR
  246.         i,x,y,c  : CARDINAL;
  247.  
  248.       BEGIN
  249.        FOR i:= 0 TO 500 DO
  250.          x :=Random(639);
  251.          y :=Random(399);
  252.          SetAPen(wp^.RPort,1);
  253.          WritePixel(wp^.RPort,x,y);
  254.        END;
  255.     END Stars;
  256.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  257.     PROCEDURE Sexplosion(mis:Shell;wp: WindowPtr);
  258.       VAR
  259.         i,j,k,x,y,x1,y1 : CARDINAL;
  260.  
  261.       BEGIN
  262.         FOR i:=0 TO 50 DO
  263.           j:= (i DIV 5)+5;
  264.           k:= j * 2;
  265.           x:= (CARDINAL(mis.x) - j)+Random(k) ;
  266.           y:= (CARDINAL(mis.y) - j)+Random(k) ;
  267.           SetAPen(wp^.RPort,2);
  268.           WritePixel(wp^.RPort,x,y);
  269.         END;
  270.         FOR i:=0 TO 500 DO
  271.           j:= (i DIV 25)+5;
  272.           k:= j * 2;
  273.           x:= (CARDINAL(mis.x) - j)+Random(k) ;
  274.           y:= (CARDINAL(mis.y) - j)+Random(k) ;
  275.           x1:= (CARDINAL(mis.x) - 5)+Random(10) ;
  276.           y1:= (CARDINAL(mis.y) - 5)+Random(10) ;
  277.           k:= Random(3);
  278.           SetAPen(wp^.RPort,0);
  279.           WritePixel(wp^.RPort,x1,y1);
  280.           SetAPen(wp^.RPort,k);
  281.           WritePixel(wp^.RPort,x,y);
  282.         END;
  283.     END Sexplosion;
  284.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  285.     PROCEDURE Pexplosion(mis:Shell;wp: WindowPtr);
  286.       VAR
  287.         debry : ARRAY [0..2],[0..20] OF CARDINAL;
  288.         i,j,k,l : CARDINAL;
  289.  
  290.       BEGIN
  291.         l:=0;
  292.         i:=0;
  293.         WHILE ((l<20)AND(i<100)) DO
  294.           j:= 10*(1+(i DIV 50)) + (l DIV 4);
  295.           k:= j * 2;
  296.           debry[0,l]:= (CARDINAL(mis.x) - j)+Random(k) ;
  297.           debry[1,l]:= (CARDINAL(mis.y) - j)+Random(k) ;
  298.           debry[2,l]:= ReadPixel(wp^.RPort,debry[0,l],debry[1,l]);
  299.           IF debry[2,l]=0 THEN
  300.             SetAPen(wp^.RPort,2);
  301.             WritePixel(wp^.RPort,debry[0,l],debry[1,l]);
  302.             l:=l+1;
  303.           END;
  304.           i:=i+1;
  305.         END;
  306.         FOR i:=0 TO l DO
  307.           SetAPen(wp^.RPort,debry[2,i]);
  308.           WritePixel(wp^.RPort,debry[0,i],debry[1,i]);
  309.         END;
  310.     END Pexplosion;
  311.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  312.     PROCEDURE DrawLine (x1,y1,x2,y2,c : CARDINAL; wp : WindowPtr);
  313.       BEGIN
  314.         WITH wp^ DO
  315.           SetAPen (RPort,c); SetDrMd (RPort, Jam1);
  316.           Move (RPort ,x1, y1);  Draw (RPort , x2, y2);
  317.         END
  318.     END DrawLine;
  319.  
  320.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  321.     PROCEDURE DrawShip(x1,y1,x2,y2 : CARDINAL; wp : WindowPtr);
  322.  
  323.       VAR 
  324.         n,X1,X2,Y1,Y2 : INTEGER;
  325.         pts : ARRAY [0..42] OF INTEGER;
  326.         xa,xb,ya,yb : CARDINAL;
  327.  
  328.       BEGIN
  329.       X1:=CARDINAL(x1);
  330.       X2:=CARDINAL(x2);
  331.       Y1:=CARDINAL(y1);
  332.       Y2:=CARDINAL(y2);
  333.      pts[0]:=17; pts[1]:=7; pts[2]:=15; pts[3]:=17; pts[4]:=6;  pts[5]:=15;
  334.      pts[6]:=8;  pts[7]:=5; pts[8]:=3;  pts[9]:=7; pts[10]:=4; pts[11]:=3;
  335.      pts[12]:=6; pts[13]:=3;pts[14]:=3; pts[15]:=5;pts[16]:=2; pts[17]:=3;
  336.      pts[18]:=8; pts[19]:=1;pts[20]:=26;pts[21]:=9;pts[22]:=0; pts[23]:=27;
  337.      pts[24]:=0; pts[25]:=2;pts[26]:=18;pts[27]:=(-4);pts[28]:=3; pts[29]:=13;
  338.      pts[30]:=(-4);pts[31]:=4;pts[32]:=13;pts[33]:=(-5);pts[34]:=5; pts[35]:=11;
  339.      pts[36]:=(-6);pts[37]:=6;pts[38]:=9; pts[39]:=(-8);pts[40]:=7; pts[41]:=5;
  340.  
  341.         FOR n:= 0 TO 41 BY 3 DO
  342.          xa:=CARDINAL(X1-pts[n]);
  343.          ya:=CARDINAL(Y1-pts[n+1]);
  344.          xb:=CARDINAL(X1-pts[n]+pts[n+2]);
  345.          yb:=CARDINAL(Y1-pts[n+1]);
  346.          DrawLine(xa,ya,xb,yb,3,wp);
  347.          xa:=CARDINAL(X1-pts[n]);
  348.          ya:=CARDINAL(Y1+pts[n+1]);
  349.          xb:=CARDINAL(X1-pts[n]+pts[n+2]);
  350.          yb:=CARDINAL(Y1+pts[n+1]);
  351.          DrawLine(xa,ya,xb,yb,3,wp);
  352.         END;
  353.  
  354.     pts[0]:=2; pts[1]:=7; pts[2]:=1;      pts[3]:=2; pts[4]:=6;  pts[5]:=1;
  355.     pts[6]:=(-10); pts[7]:=1; pts[8]:=1;  pts[9]:=(-9); pts[10]:=0; pts[11]:=3;
  356.  
  357.         FOR n:= 0 TO 11 BY 3 DO
  358.          xa:=CARDINAL(X1-pts[n]);
  359.          ya:=CARDINAL(Y1-pts[n+1]);
  360.          xb:=CARDINAL(X1-pts[n]+pts[n+2]);
  361.          yb:=CARDINAL(Y1-pts[n+1]);
  362.          DrawLine(xa,ya,xb,yb,2,wp);
  363.          xa:=CARDINAL(X1-pts[n]);
  364.          ya:=CARDINAL(Y1+pts[n+1]);
  365.          xb:=CARDINAL(X1-pts[n]+pts[n+2]);
  366.          yb:=CARDINAL(Y1+pts[n+1]);
  367.          DrawLine(xa,ya,xb,yb,2,wp);
  368.         END;
  369.  
  370.      pts[0]:=17; pts[1]:=7; pts[2]:=12; pts[3]:=17; pts[4]:=6;  pts[5]:=13;
  371.      pts[6]:=14; pts[7]:=5; pts[8]:=11; pts[9]:=13; pts[10]:=4; pts[11]:=11;
  372.      pts[12]:=12;pts[13]:=3;pts[14]:=11; pts[15]:=11;pts[16]:=2; pts[17]:=11;
  373.      pts[18]:=12;pts[19]:=1;pts[20]:=30;pts[21]:=12;pts[22]:=0; pts[23]:=30;
  374.      pts[24]:=(-12);pts[25]:=2;pts[26]:=5;pts[27]:=(-13);pts[28]:=3; pts[29]:=3;
  375.      pts[30]:=(-14);pts[31]:=4;pts[32]:=1;
  376.  
  377.         FOR n:= 0 TO 32 BY 3 DO
  378.          xa:=CARDINAL(X2+pts[n]);
  379.          ya:=CARDINAL(Y2-pts[n+1]);
  380.          xb:=CARDINAL(X2+pts[n]-pts[n+2]);
  381.          yb:=CARDINAL(Y2-pts[n+1]);
  382.          DrawLine(xa,ya,xb,yb,3,wp);
  383.          xa:=CARDINAL(X2+pts[n]);
  384.          ya:=CARDINAL(Y2+pts[n+1]);
  385.          xb:=CARDINAL(X2+pts[n]-pts[n+2]);
  386.          yb:=CARDINAL(Y2+pts[n+1]);
  387.          DrawLine(xa,ya,xb,yb,3,wp);
  388.         END;
  389.  
  390.         pts[0]:=18; pts[1]:=7; pts[2]:=1; pts[3]:=18; pts[4]:=6;  pts[5]:=1;
  391.         pts[6]:=3; pts[7]:=1; pts[8]:=1;  pts[9]:=3; pts[10]:=0; pts[11]:=1;
  392.  
  393.         FOR n:= 0 TO 11 BY 3 DO
  394.          xa:=CARDINAL(X2+pts[n]);
  395.          ya:=CARDINAL(Y2-pts[n+1]);
  396.          xb:=CARDINAL(X2+pts[n]-pts[n+2]);
  397.          yb:=CARDINAL(Y2-pts[n+1]);
  398.          DrawLine(xa,ya,xb,yb,2,wp);
  399.          xa:=CARDINAL(X2+pts[n]);
  400.          ya:=CARDINAL(Y2+pts[n+1]);
  401.          xb:=CARDINAL(X2+pts[n]-pts[n+2]);
  402.          yb:=CARDINAL(Y2+pts[n+1]);
  403.          DrawLine(xa,ya,xb,yb,2,wp);
  404.         END;
  405.     END DrawShip;
  406.  
  407. END GW.
  408.  
  409.